HPAVC/HPAVC CD-ROM.iso/pc/XMSLI202.ZIP/XMSDEMO.PAS

Pascal/Delphi Source File | 1994-03-17 | 5.5 KB | 178 lines

Program XMSLibDemo;
{ Copyright (c) 1994 by Andrew Eigus              Fido Net: 2:5100/20.12 }
{ XMS Interface V2.02 for Turbo Pascal version 7.0 demonstration program }

(*
  Tested on IBM 486 SX 33Mhz with 4MB RAM with the following configuration:
     1)  HIMEM.SYS  (MS-DOS 6.2 XMS memory manager)
     2)  HIMEM.SYS  (MS-DOS 6.2 XMS memory manager)
     EMM386.EXE (MS-DOS 6.2 EMS memory manager)

  If any inpredictable errors occur in your system while running this demo,
  please be so kind to inform me:

    AndRew's BBS Phone: [phone] (Riga, Latvia) 24h 2400bps
    Voice Phone:        [phone]
    Fido Net:        2:5100/20.12
*)

{X+}{$R-}

uses XMSLib;

type
  TMsg = array[1..14] of Char;

  TUMBAllocRec = record
    Size : word;
    SegAddr : word
  end;

const
  Message1 : TMsg = 'First message ';
  Message2 : TMsg = 'Second message';

  YesNo : array[boolean] of string[3] = ('No', 'Yes');
  A20State : array[boolean] of string[8] = ('Disabled', 'Enabled');

var
  Version, Memory, Handle, BlockLength : word;
  Locks, FreeHandles : byte;
  HMAAvailable : boolean;
  Address : pointer;
  UMB : longint;

Function Hex(Num : longint; Places : byte) : string;
const HexTab : array[0..15] of Char = '0123456789ABCDEF';
var
  HS : string[8];
  Digit : byte;
Begin
  HS[0] := Chr(Places);
  for Digit := Places downto 1 do
  begin
    HS[Digit] := HexTab[Num and $0000000F];
    Num := Num shr 4
  end;
  Hex := HS
End; { Hex }

Function Check(Result : byte; Func : string) : byte;
Begin
  if Result <> xmsrOk then
    WriteLn(Func, ' returned ',
      Hex(Result, 2), 'h (', Result, '): ', XMS_GetErrorMsg(Result));
  Check := Result
End; { Check }

Procedure ShowA20State;
var State : boolean;
Begin
  State := XMS_QueryA20;
  if Check(XMSResult, 'XMS_QueryA20') = xmsrOk then
    WriteLn('A20 state: ', A20State[State])
End; { ShowA20State }

Procedure Wait4Return;
Begin
  WriteLn;
  WriteLn('Press ENTER to continue');
  ReadLn
end; { Wait4Return }


Begin
  WriteLn('XMS Library V2.02 Demonstration program by Andrew Eigus'#10);
  if XMS_Setup then
  begin

    Version := XMS_GetVersion(XMS);
    if Check(XMSResult, 'XMS_GetVersion(XMS)') = xmsrOk then
      WriteLn('XMS version ', Hi(Version), '.', Lo(Version), ' present');
    Version := XMS_GetVersion(XMM);
    if Check(XMSResult, 'XMS_GetVersion(XMM)') = xmsrOk then
      WriteLn('XMM version ', Hi(Version), '.', Lo(Version), ' detected');
    HMAAvailable := XMS_HMAAvail;
    if Check(XMSResult, 'XMS_HMAAvail') = xmsrOk then
      WriteLn('HMA Available: ', YesNo[HMAAvailable]);

    WriteLn;
    Memory := XMS_MemAvail;
    if Check(XMSResult, 'XMS_MemAvail') = xmsrOk then
      WriteLn('Free XMS memory available: ', Memory, ' KB')
    else
      if XMSResult = xmsrNoMoreMem then Halt(xmsrNoMoreMem);
    Memory := XMS_MaxAvail;
    if Check(XMSResult, 'XMS_MaxAvail') = xmsrOk then
      WriteLn('Largest XMS memory block: ', Memory, ' KB');

    WriteLn;
    if HMAAvailable then
      if Check(XMS_AllocHMA($FFFF), 'XMS_AllocHMA') = xmsrOk then
      begin
        WriteLn('HMA: Block allocated');
        if Check(XMS_FreeHMA, 'XMS_FreeHMA') = xmsrOk then
          WriteLn('HMA: Block released')
      end;

    Wait4Return;

    WriteLn('XMS data transfer test'#10);
    WriteLn('Message1: ', Message1);
    WriteLn('Message2: ', Message2);

    Handle := XMS_AllocEMB(1);
    if Check(XMSResult, 'XMS_AllocEMB') = xmsrOk then
    begin
      WriteLn('1 KB EMB allocated. Handle number: ', Hex(Handle, 4), 'h');
      { Now copy our little Message1 to extended memory }
      if Check(XMS_MoveToEMB(Handle, Message1, SizeOf(TMsg)),
        'XMS_MoveToEMB') = xmsrOk then WriteLn('Transfer to XMS: OK');
      { Now copy it back to the second string }
      if Check(XMS_MoveFromEMB(Handle, Message2, SizeOf(TMsg)),
        'XMS_MoveFromEMB') = xmsrOk then WriteLn('Transfer from XMS: OK');
      WriteLn('Message1: ', Message1);
      WriteLn('Message2: ', Message2);
      WriteLn;
      if Check(XMS_ReallocEMB(Handle, 2),
        'XMS_ReallocEMB') = xmsrOk then
        WriteLn('EMB reallocated. New size: 2 KB');
      WriteLn;
      Address := XMS_LockEMB(Handle);
      if Check(XMSResult, 'XMS_LockEMB') = xmsrOk then
        WriteLn('EMB locked at linear memory address ',
          Hex(Longint(Address), 8), 'h');

      WriteLn;
      FreeHandles := XMS_EMBHandlesAvail(Handle);
      if Check(XMSResult, 'XMS_EMBHandlesAvail') = xmsrOk then
        WriteLn('EMB Handles available: ', FreeHandles);
      Locks := XMS_EMBLockCount(Handle);
      if Check(XMSResult, 'XMS_EMBLockCount') = xmsrOk then
        WriteLn('EMB Lock count: ', Locks);
      BlockLength := XMS_EMBSize(Handle);
      if Check(XMSResult, 'XMS_EMBSize') = xmsrOk then
        WriteLn('EMB Length: ', BlockLength, ' KB');

      WriteLn;
      if Check(XMS_UnlockEMB(Handle), 'XMS_UnlockEMB') = xmsrOk then
          WriteLn('EMB unlocked');

      WriteLn;
      if Check(XMS_FreeEMB(Handle), 'XMS_FreeEMB') = xmsrOk then
        WriteLn('EMB released');

      Wait4Return
    end;

    UMB := XMS_AllocUMB($FFFF);
    if Check(XMSResult, 'XMS_AllocUMB') = xmsrOk then
    begin
      WriteLn('UMB allocated at segment base ',
        Hex(TUMBAllocRec(UMB).SegAddr, 4), 'h');
      WriteLn('Actual size: ', TUMBAllocRec(UMB).Size, ' paragraphs'#10);
      if Check(XMS_FreeUMB(TUMBAllocRec(UMB).SegAddr),
        'XMS_FreeUMB') = xmsrOk then WriteLn('UMB released')
    end;
  end else WriteLn('XMS not present.')
End.